home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / OBJ1_2.ZIP;1 / OBJECT3.PRG < prev    next >
Encoding:
Text File  |  1993-01-28  |  42.4 KB  |  1,391 lines
  1. //*****************************************************************************
  2. // OBJECT3.PRG
  3. // Various functions for OBJECT v2.03
  4. // Copyright (c) 1991, JHK, JHK-Software, Piestany
  5. // Please compile with: /N/M/W/A
  6. //-----------------------------------------------------------------------------
  7.  
  8. #include "Set.ch"
  9. #include "Box.ch"
  10. #include "InKey.ch"
  11. #include "error.ch"
  12. #include "FileIo.ch"
  13. #include "SetCurs.ch"
  14. #include "MemoEdit.ch"
  15. #include "Object.ch"
  16.  
  17. static DatabInfo:={}   //database info array for save/restore the database state
  18. static aMessages:={}   //dialog_out_lines
  19. static CurColSize      //current memo
  20. static CurLastKey      //current memo
  21.  
  22. //*****************************************************************************
  23. // IncludeFunctions() --> true
  24. // this fnc isn't called from anything other fnc!
  25. // it is used only for linking need functions for entering
  26. // Filter & Index expressions
  27. //
  28. function IncludeFunctions()
  29.   local c,n,d,l,e
  30.   Abs(n);      AllTrim(c);   Asc(n);        At(c,c);    CdoW(d);    Chr(c)
  31.   CMonth(d);   CtoD(c);      Date();        Day(d);     Descend(e); DoW(d)
  32.   DtoC(d);     DtoS(d);      Empty(e);      Exp(n);     GetEnv(c);  If(l,e,e)
  33.   IsAlpha(c);  IsDigit(c);   IsLower(c);    IsUpper(c); Left(c,n);  Log(n)
  34.   Lower(c);    LTrim(c);     Max(n,n);      Min(n,n);   Month(d);   PadC(e,n,c)
  35.   PadL(e,n,c); PadR(e,n,c);  Right(c,n);    Round(n,n); RTrim(c);   Sqrt(n)
  36.   Str(n,n,n);  StrTran(c,c); SubStr(c,n,n); Trans(e,c); Type(e);    Upper(c)
  37.   Val(c);      ValType(e);   Year(d);       FError()
  38.   return(true)
  39.  
  40.  
  41. //*****************************************************************************
  42. // AValid(Name,Get,Array,Block,EmptyAllowed) --> true/false
  43. // validation from string array, block usage: Eval(Block,e)==Get:VarGet()
  44. // e ... one_element_from_Array
  45. //
  46. function AValid(Name,Get,Array,Block,EmptyAllowed)
  47.   local Ch,Var,Ln
  48.   default Name to ResTxt(034)
  49.   default EmptyAllowed to false
  50.   default Get:ExitState to true
  51.   if !Get:Changed and EmptyAllowed; return(true); endif
  52.   if Empty(Array); return(false); endif
  53.   Var:=if(Empty(Get:Picture),Get:VarGet(),Transform(Get:VarGet(),Get:Picture))
  54.   default Block to {|e|e}
  55.   if AScan(Array,{|e|Eval(Block,e)==Var})>0; return(true); endif
  56.   object Ch of Choice
  57.   Ln:=Len(Var)
  58.   Ch:FastInit(Name,Row(),Col()+Ln,Ln,Array)
  59.   Ch:Process()
  60.   if Ch:Choice>0
  61.     if !Get:ExitState; Get:VarPut(Eval(Block,Array[Ch:Choice])); endif
  62.     Ch:Done()
  63.     SetLastKey(K_ENTER)
  64.     return(true)
  65.   endif
  66.   Ch:Done()
  67.   if LastKey()==K_ESC; SetLastKey(0); endif
  68.   return(false)
  69.  
  70.  
  71. //*****************************************************************************
  72. // DbfValid(Name,Get,DbfName,Index,Block,EmptyAllowed,Fields)
  73. // validation from database, must be indexed!
  74. // block usage: Eval(Block)==Get:VarGet()  //RecNo() is correctly setted.
  75. //
  76. function DbfValid(Name,Get,DbfName,Index,Block,EmptyAllowed,Fields)
  77.   local s,o,Db,w,k,Rv,i
  78.   default EmptyAllowed to false
  79.   if !Get:Changed and EmptyAllowed; return(true); endif
  80.   default Name to ResTxt(034)
  81.   default Get:ExitState to true
  82.   s:=Select()
  83.   select (DbfName)
  84.   o:=IndexOrd()
  85.   if Index<>nil; set order to Index; endif
  86.   seek if(Empty(Get:Picture),Get:VarGet(),Transform(Get:VarGet(),Get:Picture))
  87.   if Found()
  88.     set order to (o)
  89.     select (s)
  90.     skip 0
  91.     return(true)
  92.   endif
  93.   *
  94.   SetCursor(SC_NONE)
  95.   w:=0
  96.   if Empty(Fields)
  97.     Fields:={}
  98.     for i:=1 to FCount()
  99.       if( !(ValType(FieldGet(i))=="M"), AAdd(Fields,FieldName(i)), )
  100.     endfor
  101.   endif
  102.   AEval(Fields,{|e|w+=3+Max(Len(Transform(&(e),)),Len(e))})
  103.   object Db of UpDBrowse
  104.   Db:GoodInit(Name,Row(),Col(),Min(LastRec()+2,MaxRow()-5),Min(w,MaxCol()-9),1)
  105.   AEval(Fields,{|e|Db:AddBlock(,e,DbfName+"->"+e,FieldBlock(e))})
  106.   go top
  107.   if Eof(); set order to (o); select (s); return(false); endif
  108.   Db:Alias:=DbfName
  109.   Db:RecNo:=RecNo()
  110.   Db:CanEdit:=false
  111.   Db:CanSwap:=false
  112.   Db:FormActive:=false
  113.   Db:IndexNo:=if(Empty(Index),IndexOrd(),Index)
  114.   Db:FilterExp:=DbFilter()
  115.   Db:Paint()
  116.   k:=SetKey(K_ENTER,{||StuffKey(K_CTRL_RET)})
  117.   Db:Process()
  118.   SetKey(K_ENTER,k)
  119.   if LastKey()==K_CTRL_RET or LastKey()==K_ENTER
  120.     if !Get:ExitState; Get:VarPut(Eval(Block)); endif
  121.     SetLastKey(K_ENTER)
  122.     Rv:=true
  123.   else
  124.     if LastKey()==K_ESC; SetLastKey(0); endif
  125.     Rv:=false
  126.   endif
  127.   Db:Done()
  128.   set order to (o)
  129.   select (s)
  130.   skip 0
  131.   return(Rv)
  132.  
  133.  
  134. //*****************************************************************************
  135. // OAlert(cMessage,aOptions,nRow,nInitItem) --> nChoice
  136. // standart alert with shadow
  137. //
  138. function OAlert(cMessage,aOptions,nRow,nInitItem)
  139.   local k1,ks1
  140.   local R,C,Rs,Cs,R2,C2,Scr,nChoice,m,i
  141.   local ClrMnu,ClrBox
  142.   local OldRow:=Row()
  143.   local OldCol:=Col()
  144.   default aOptions to {"Ok"}
  145.   m:=SetDialog(.t.)
  146.   Rs:=3+Len(cMessage)-Len(StrTran(cMessage,";"))
  147.   Cs:=Max(2+GetMaxRow(cMessage),4+ACount(aOptions))
  148.   R:=if(nil<>nRow,nRow,Int((MaxRow()-Rs-1)/2))
  149.   C:=Int((MaxCol()-Cs-1)/2)
  150.   R2:=R+Rs+1
  151.   C2:=C+Cs+1
  152.   SaveDOut(if(Len(aOptions)>1,ResTxt(138),ResTxt(137)))
  153.   Scr:=SaveScr(R,C,R2+1,C2+1)
  154.     if m->tColor==3  //true color
  155.       i:=ListAsArray(m->Color:Edit)
  156.       ClrBox:=GetFore(m->Color:Desk)+"/"+GetBack(i[nEnhanced])
  157.       ClrMnu:=i[nEnhanced]+","+GetFore(ListAsArray(m->Color:Menu)[nLetter])+"/"+GetBack(i[nNormal])
  158.     else
  159.       ClrBox:="n/w"
  160.       ClrMnu:="n/w,w+/n"
  161.     endif
  162.     SetColor(ClrMnu)
  163.     @ R,C,R2,C2 box B_SINGLE+" " color ClrBox
  164.     AEval(ListAsArray(cMessage,";"),{|e,i|DevPos(R+i,C+1),DevOut(PadC(e,Cs))})
  165.     i:=0
  166.     AEval(aOptions,{|e,j|aOptions[j]:=" "+AllTrim(e)+" ",i+=1+Len(aOptions[j])})
  167.     SetPos(Row()+2,C+(Cs-i)/2+1)
  168.     AEval(aOptions,{|e|MyMenuTo(Row(),Col()+1,e)})   //@ Row,Col PROMPT ...
  169.     if m->tColor<>0; BoxShadow(R,C,R2,C2); endif
  170.     k1:=SetKey(K_F1,nil)
  171.     ks1:=SetKey(K_SH_F1,nil)
  172.     nChoice:=MyMenuTo(nInitItem)  //MENU TO
  173.     SetKey(K_F1,k1)
  174.     SetKey(K_SH_F1,ks1)
  175.   RestScr(Scr)
  176.   RestDOut()
  177.   SetDialog(m)
  178.   SetPos(OldRow,OldCol)
  179.   return(nChoice)
  180.  
  181. static function GetMaxRow(cMsg)
  182.   return(if(At(";",cMsg)>0, AWidth(ListAsArray(cMsg,";")), Len(cMsg)+4))
  183.  
  184. static function ACount(aOpt)
  185.   local n:=0
  186.   AEval(aOpt,{|e|n+=4+Len(e)})
  187.   return(n-2)
  188.  
  189. static function MyMenuTo(R,C,S)
  190.   static Items:={}
  191.   local i,j,Ch,nChoice
  192.   local Norm:=SetColor()
  193.   local Enh:=ListAsArray(SetColor())[nEnhanced]
  194.   local Curs:=SetCursor(SC_NONE)
  195.   if PCount()==3  //AtPrompt
  196.     @ R,C say S
  197.     AAdd(Items,{R,C,S})
  198.   else //MenuTo
  199.     i:=if(Empty(R),1,R)
  200.     repeat
  201.       SetCursor(SC_NONE)
  202.       @ Items[i,1],Items[i,2] say Items[i,3] color Enh
  203.       nChoice:=PauseKey(0)
  204.       do case
  205.         case nChoice==K_ENTER; nChoice:=i; exit
  206.         case nChoice==K_ESC;   nChoice:=0; exit
  207.         otherwise
  208.           Ch:=Upper(Chr(nChoice))
  209.           j:=AScan(Items,{|e|Upper(SubStr(e[3],2,1))==Ch},i)
  210.           if j==0; j:=AScan(Items,{|e|Upper(SubStr(e[3],2,1))==Ch}); endif
  211.           if j>0; nChoice:=j; exit; endif
  212.       endcase
  213.       @ Items[i,1],Items[i,2] say Items[i,3] color Norm
  214.       do case
  215.         case nChoice==K_LEFT;  if( i>1, i--, if(Set(_SET_WRAP),i:=Len(Items),))
  216.         case nChoice==K_RIGHT; if( i<Len(Items), i++, if(Set(_SET_WRAP),i:=1,))
  217.       endcase
  218.     endrepeat
  219.     Items:={}
  220.   endif
  221.   SetCursor(Curs)
  222.   return nChoice
  223.  
  224.  
  225. //*****************************************************************************
  226. // Memo(bVar,lEdit,cTitle,Row,Col,RowSize,ColSize,CurSize,Color,lShadow) --> true ???
  227. // windowed edit one memo variable
  228. //
  229. function Memo(bVar,lEdit,cTitle,Row,Col,RowSize,ColSize,CurSize,Color,lShadow)
  230.   local OldCs,OldKey,OldWFK
  231.   local OldC:=SetColor()
  232.   local object Win of Win
  233.   local object Cursor of Cursor; Cursor:Get()
  234.   default cTitle to ResTxt(021)
  235.   default CurSize to Len(ResTxt(134))-2
  236.   default Row to Row()
  237.   default Col to Col()+CurSize+1
  238.   default RowSize to Int(MaxRow()/3)
  239.   default ColSize to Int(MaxCol()/2)
  240.   default Color to if(lEdit,m->Color:Edit,m->Color:View)
  241.   SaveHelpIdx(if(lEdit,{12},{15,11}))
  242.   SaveDOut(ResTxt(148)+if(!Empty(SetDMsg()),","+SetDMsg(),""))
  243.   Win:GoodInit(cTitle,Row,Col,RowSize,ColSize,CurSize,Color,lShadow)
  244.   OldCs:=CurColSize
  245.   Row:=Win:Row
  246.   Col:=Win:Col
  247.   RowSize:=Win:RowSize
  248.   ColSize:=CurColSize:=Win:ColSize
  249.   Win:Paint()
  250.   if m->tColor==3
  251.     Color:=ListAsArray(Color)
  252.     Color:=GetFore(Color[nUnSelect])+"/"+GetBack(Color[nNormal])
  253.   endif
  254.   SetColor(Color)
  255.   OldWFK:=SetKey(nWaitForKey,{||WaitKey()})
  256.   if lEdit
  257.     SetCursor(if(ReadInsert(),SC_INSERT,SC_NORMAL))
  258.     CurLastKey:=nil
  259.     OldKey:=SetKey(nSwapTask,{||StuffKey(K_CTRL_W),CurLastKey:=nSwapTask})
  260.     begin sequence
  261.     Eval(bVar,MemoEdit(Eval(bVar), Row+1,Col+1, Row+RowSize,Col+ColSize, true,"MemoEditFnc",if(SetMemoWrap(),ColSize,250)))
  262.     end sequence
  263.     SetKey(nSwapTask,OldKey)
  264.     if CurLastKey<>nil; SetLastKey(CurLastKey); endif
  265.   else
  266.     MemoViewFnc(-1)  //preInit
  267.     begin sequence
  268.     MemoEdit(Eval(bVar), Row+1,Col+1, Row+RowSize,Col+ColSize, false,"MemoViewFnc",if(SetMemoWrap(),ColSize,250),4, RowSize,0,RowSize)
  269.     end sequence
  270.   endif
  271.   SetKey(nWaitForKey,OldWFK)
  272.   SetCursor(SC_NONE)
  273.   CurColSize:=OldCs
  274.   Win:Done()
  275.   RestHelpIdx()
  276.   RestDOut()
  277.   SetColor(OldC)
  278.   Cursor:Set()
  279.   return(true)
  280.  
  281.  
  282. static procedure WaitKey()
  283.   while NextKey()==0; ShowTime(); endwhile
  284.   return
  285.  
  286.  
  287. function MemoEditFnc(nMode)
  288.   local nKey:=LastKey()
  289.   if nKey==nSwapTask or nKey==K_CTRL_RET
  290.     CurLastKey:=nKey
  291.     StuffKey(K_CTRL_W)
  292.     return(ME_DEFAULT)
  293.   endif
  294.   if nKey==K_INS
  295.     SetCursor(if(Set(_SET_INSERT),SC_NORMAL,SC_INSERT))
  296.   endif
  297.   if( nKey<>K_CTRL_W and nKey<>K_ESC and nKey<>K_CTRL_RET and NextKey()==0, StuffKey(nWaitForKey), )
  298.   return(ME_DEFAULT)
  299.  
  300.  
  301. function MemoViewFnc(nMode)
  302.   static initialized:=false
  303.   local nKey:=LastKey()
  304.   breakif nKey==nSwapTask or nKey==K_CTRL_RET
  305.   if nMode==ME_INIT
  306.     returnif initialized with ME_DEFAULT
  307.     initialized:=true
  308.     SetCursor(SC_SPECIAL1)
  309.     return ME_TOGGLESCROLL
  310.   elseif nMode==-1
  311.     initialized:=false  //preInit
  312.   endif
  313.   if( nKey<>K_CTRL_W and nKey<>K_ESC and nKey<>K_CTRL_RET and NextKey()==0, StuffKey(nWaitForKey), )
  314.   return(ME_DEFAULT)
  315.  
  316.  
  317. function SetMemoWrap(new)
  318.   static old:=true
  319.   return old update with new
  320.  
  321.  
  322. //*****************************************************************************
  323. // EditGetMsg(get,lCanEdit) --> true
  324. // edit one get object, with messages
  325. //
  326. function EditGetMsg(Get,CanEdit)
  327.   local Msg,ah
  328.   Default CanEdit to true
  329.   Msg:=if(CanEdit,ResTxt(152),ResTxt(153))
  330.   SaveDOut(Msg+if(!Empty(SetDMsg()),","+SetDMsg(),""))
  331.   if (Upper(ProcName(1))=="EDITIT")
  332.     ah:={if(CanEdit,18,17)}
  333.   else
  334.     ah:={if(CanEdit,10,9),1}
  335.   endif
  336.   SaveHelpIdx(ah)
  337.   EditGet(get,CanEdit)
  338.   RestHelpIdx()
  339.   RestDOut()
  340.   return(true)
  341.  
  342.  
  343. //*****************************************************************************
  344. // EditGet(get,lCanEdit) --> true
  345. // edit one get object
  346. //
  347. function EditGet(Get,CanEdit)
  348.   local Ch,IsMemo,oldValue
  349.   default CanEdit to true
  350.   if GetPreValidate(Get,@CanEdit)
  351.     IsMemo:=Transform(Get:VarGet(),)==ResTxt(134)
  352.     ReadHelpVar(Get:Name)
  353.     Get:SetFocus()
  354.     oldValue:=Get:VarGet()
  355.     repeat
  356.       Get:ExitState:=false
  357.       SetCursor(if(ReadInsert(),SC_INSERT,SC_NORMAL))
  358.       GetApplyKey(Get,GetKey(0),@CanEdit,IsMemo)
  359.     until Get:ExitState and GetPostValidate(Get,@CanEdit,IsMemo,oldValue)
  360.     Get:KillFocus()
  361.     ReadHelpVar("")
  362.     SetCursor(SC_NONE)
  363.   else
  364.     InKey()  //need for c_browse.prg, disable endless loop ???
  365.   endif
  366.   return(true)
  367.  
  368. static function GetPreValidate(Get,CanEdit)
  369.   local When:=true
  370.   if Get:PreBlock<>nil
  371.     Get:ExitState:=!CanEdit
  372.     When:=Eval(Get:PreBlock,Get,@CanEdit)
  373.     Get:Display()
  374.   endif
  375.   return(When)
  376.  
  377. static function GetPostValidate(Get,CanEdit,IsMemo,oldValue)
  378.   local Valid:=true
  379.   if Get:BadDate(); Get:Home(); return(!CanEdit); endif
  380.   if Get:Changed(); Get:Assign(); endif
  381.   Get:Reset()
  382.   if Get:PostBlock<>nil and !(LastKey()==K_CTRL_RET and IsMemo)
  383.     Get:ExitState:=!CanEdit
  384.     Valid:=Eval(Get:PostBlock,Get,@CanEdit,oldValue)
  385.     Get:UpdateBuffer()
  386.   endif
  387.   return(Valid or (!CanEdit and !IsMemo))
  388.  
  389. static function GetApplyKey(Get,Ch,CanEdit,IsMemo)
  390.   if SetKey(Ch)<>nil; GetDoSetKey(Ch,Get); return(true); endif
  391.   do case
  392.     case Ch==K_INS;         Set(_SET_INSERT,!Set(_SET_INSERT))
  393.     case Ch==K_HOME;        Get:Home()
  394.     case Ch==K_END;         Get:End()
  395.     case Ch==K_LEFT;        Get:Left()
  396.     case Ch==K_RIGHT;       Get:Right()
  397.     case Ch==K_CTRL_LEFT;   Get:WordLeft()
  398.     case Ch==K_CTRL_RIGHT;  Get:WordRight()
  399.     case Ch==K_BS;          Get:BackSpace()
  400.     case Ch==K_DEL;         Get:Delete()
  401.     case Ch==K_CTRL_BS;     Get:DelWordLeft()
  402.     case Ch==K_CTRL_T;      Get:DelWordRight()
  403.     case Ch==K_CTRL_Y;      Get:DelEnd()
  404.     otherwise
  405.       if Ch<32 or Ch>254; GetDone(Get); return(true); endif
  406.       if CanEdit and !IsMemo
  407.         Ch:=Chr(Ch)
  408.         if Get:Type=="N" and Ch$".,"
  409.           Get:ToDecPos()
  410.         else
  411.           if Set(_SET_INSERT); Get:Insert(Ch); else; Get:Overstrike(Ch); endif
  412.         endif
  413.       endif
  414.   endcase
  415.   if Get:TypeOut and !Set(_SET_CONFIRM)
  416.     if Set(_SET_BELL); Bell(); endif
  417.     Get:ExitState:=true
  418.     SetLastKey(K_ENTER)
  419.   endif
  420.   return(true)
  421.  
  422. static function GetDoSetKey(Ch,Get)
  423.   if Get:Changed; Get:Assign(); endif
  424.   Eval(SetKey(Ch),ProcName(3),ProcLine(3),Get:Name)
  425.   Get:UpdateBuffer()
  426.   return(true)
  427.  
  428. static function GetDone(Get)
  429.   if Get:Changed; Get:Assign(); endif
  430.   Get:ExitState:=true
  431.   return(true)
  432.  
  433.  
  434. //*****************************************************************************
  435. // EditIt(xValue,cMessage,cPicture,Row,Col,Color,cVarName,IsPassword) --> xEditedValue
  436. // edit one variable
  437. //
  438. function EditIt(xVal,cMsg,cPic,R,C,Clr,VarName,IsPsw)
  439.   local rv
  440.   SaveDOut("")
  441.   rv:=EditItPrim(xVal,cMsg,cPic,R,C,Clr,VarName,IsPsw)
  442.   RestDOut()
  443.   return(rv)
  444.  
  445.  
  446. //*****************************************************************************
  447. // EditItPrim(xValue,cMessage,cPicture,Row,Col,Color,cVarName,IsPassword) --> xEditedValue
  448. // Primitive of EditIt; edit one variable, don't clear dialog line
  449. //
  450. function EditItPrim(xVal,cMsg,cPic,R,C,Clr,VarName,IsPsw)
  451.   local R2,C2,Cs,Scr
  452.   local GetList:={}
  453.   local Ch
  454.   Cs:=ValType(xVal)
  455.   do case
  456.     case Cs=="D"; Cs:=Len(DtoC(xVal))
  457.     case Cs=="N"; Cs:=Len(Str(xVal))
  458.     otherwise;    Cs:=Len(xVal)
  459.   endcase
  460.   Cs+=Len(cMsg)+4
  461.   default R to Int(MaxRow()/2)
  462.   default C to Int((MaxCol()-Cs)/2)
  463.   default Clr to m->Color:Edit
  464.   default IsPsw to false
  465.   R2:=R+2
  466.   C2:=C+Cs
  467.   Scr:=SaveScr(R,C,R2+1,C2+1)
  468.   DispBegin()
  469.     @ R,C,R2,C2 box B_DOUBLE+" " color Clr
  470.     if m->tColor<>0; BoxShadow(R,C,R2,C2,ListAsArray(Clr)[nShadow]); endif
  471.     @ R+1,C+2 say cMsg color Clr get xVal picture cPic color Clr
  472.     default VarName:=DISABLE
  473.     GetList[1]:Name:=VarName  //save it for help system
  474.   DispEnd()
  475.   if IsPsw
  476.     clear gets
  477.     SaveDOut(ResTxt(144))
  478.     Clr:=ListAsArray(Clr)[nEnhanced]
  479.     R++
  480.     C+=3+Len(cMsg)
  481.     @ R,C say Replicate(" ",Len(xVal)) color Clr
  482.     xVal:=""
  483.     SetPos(R,C)
  484.     SetCursor(SC_INSERT)
  485.     ReadHelpVar(VarName)
  486.     repeat
  487.       Ch:=Chr(PauseKey(0))
  488.       do case
  489.         case Ch==Chr(K_ESC)
  490.         case Ch==Chr(K_ENTER)
  491.         case Ch==Chr(nSwapTask);  Ch:=Chr(K_ESC)
  492.         case Ch==Chr(K_CTRL_RET); Ch:=Chr(K_ENTER)
  493.         case Ch==Chr(K_BS)
  494.           if !Empty(xVal)
  495.             xVal:=Left(xVal,Len(xVal)-1)
  496.             C--
  497.             @ R,C say " " color Clr
  498.             SetPos(R,C)
  499.           endif
  500.         case ("0"<=Ch and Ch<="9") or ("A"<=Upper(Ch) and Upper(Ch)<="Z")
  501.           if C+2<C2
  502.             xVal+=Ch
  503.             C++
  504.             DispOut("*",Clr)
  505.           endif
  506.       endcase
  507.     until Ch==Chr(K_ESC) or Ch==Chr(K_ENTER)
  508.     ReadHelpVar("")
  509.     if Ch==Chr(K_ESC); xVal:=""; endif
  510.     RestDOut()
  511.   else
  512.     EditGetMsg(GetList[1],true)
  513.   endif
  514.   RestScr(Scr)
  515.   return(xVal)
  516.  
  517.  
  518. //*****************************************************************************
  519. // BoxShadow(R,C,R2,C2,Clr) --> true
  520. // draw a shadow around box.
  521. // color for shadowing is swapped nShadow element from Clr.
  522. //
  523. function BoxShadow(R,C,R2,C2,Clr)
  524.   local OldR:=R
  525.   if (R2+1)>=MaxRow(); return(false); endif
  526.   if C2>=MaxCol(); return(false); endif
  527.   default Clr to ListAsArray(SetColor())[nShadow]
  528.   Clr:="X"+chr(Color2Num(Clr,true))                 //numeric Shadow color
  529.   R:=R2:=Min(R2+1,MaxRow())
  530.   C++
  531.   C2:=Min(C2+1,MaxCol())
  532.   RestScreen(R,C,R2,C2,Transform(SaveScreen(R,C,R2,C2),Replicate(Clr,C2-C+1)))
  533.   R:=OldR+1
  534.   R2--
  535.   C:=C2
  536.   RestScreen(R,C,R2,C2,Transform(SaveScreen(R,C,R2,C2),Replicate(Clr,R2-R+1)))
  537.   return(true)
  538.  
  539.  
  540. //*****************************************************************************
  541. // Color2Num(cColor,lSwap) --> nByte_DOS_Color
  542. // Evaluate a color on the MS_DOS system color representation (numeric)
  543. // e.g. "W/N"   --> 07 (hex)
  544. // e.g. "GR+/B" --> 1E (hex)
  545. //
  546. function Color2Num(cColor,lSwap)
  547.   local nI,nJ,cFore,cBack
  548.   default lSwap to false       //true: Swap foreground and background color!
  549.   cColor:=StrTran(cColor," ")                             //delete spaces
  550.   if (nI:=At("/",cColor))<2; nI:=2; cColor:="n/w"; endif  //Extract first color
  551.   cFore:=Left(cColor,nI-1)
  552.   nJ:=At(",",cColor)                                      //Extract back colors
  553.   nJ:=iif(nJ=0, Len(cColor)+1, nJ)
  554.   cBack:=SubStr(cColor,nI+1,nJ-nI-1)
  555.   if lSwap
  556.     return(16*Ch2Num(cFore)+Ch2Num(cBack))
  557.   endif
  558.   return(16*Ch2Num(cBack)+Ch2Num(cFore))
  559.  
  560.  
  561. //-----------------------------------------------------------------------------
  562. //  Ch2Num(Char)
  563. //  conversion ONE clipper color into numeric MS_DOS value
  564. //
  565. static function Ch2Num(cC)
  566.   local nNum
  567.   nNum:=0
  568.   cC:=Upper(cC)
  569.   nNum+=iif(cC=="B", 1,0)
  570.   nNum+=iif(cC=="G", 2,0)
  571.   nNum+=iif(cC=="BG",3,0)
  572.   nNum+=iif(cC=="R", 4,0)
  573.   nNum+=iif(cC=="RB",5,0)
  574.   nNum+=iif(cC=="GR",6,0)
  575.   nNum+=iif(cC=="W", 7,0)
  576.   nNum+=iif(cC=="N+",  8,0)
  577.   nNum+=iif(cC=="B+",  9,0)
  578.   nNum+=iif(cC=="G+", 10,0)
  579.   nNum+=iif(cC=="BG+",11,0)
  580.   nNum+=iif(cC=="R+", 12,0)
  581.   nNum+=iif(cC=="RB+",13,0)
  582.   nNum+=iif(cC=="GR+",14,0)
  583.   nNum+=iif(cC=="W+", 15,0)
  584.   if (nNum=0).and. !(cC=="N"); nNum:=7; endif
  585.   return(nNum)
  586.  
  587.  
  588. //*****************************************************************************
  589. // DOut(cMsg)
  590. // output a message into dialogue line. (overwrite old message)
  591. //
  592. procedure DOut( cMsg )
  593.   local OldRow:=Row()
  594.   local OldCol:=Col()
  595.   if SetDialog()
  596.     SetDMsg(cMsg)
  597.     @ MaxRow(),0 say PadC( Left(cMsg,MaxCol()+1), MaxCol()+1 ) color m->Color:Menu
  598.     SetPos(OldRow,OldCol)
  599.   endif
  600.   return
  601.  
  602.  
  603. //*****************************************************************************
  604. // SaveDOut(cMsg)
  605. // output a message into dialogue line. (save old message)
  606. //
  607. procedure SaveDOut( cMsg )
  608.   if SetDialog()
  609.     AAdd( aMessages, SetDMsg() )
  610.     DOut( cMsg )
  611.   endif
  612.   return
  613.  
  614.  
  615. //*****************************************************************************
  616. // RestDOut(cMsg)
  617. // restore old message.
  618. //
  619. procedure RestDOut()
  620.   if !Empty(aMessages) and SetDialog()
  621.     DOut( ATailDel(aMessages) )
  622.   endif
  623.   return
  624.  
  625.  
  626. //*****************************************************************************
  627. // SetDMsg(cNew) --> OldString
  628. // save, return last dialog message
  629. //
  630. function SetDMsg(cNew)
  631.   static cOld:=""
  632.   local cc:=cOld
  633.   if SetDialog()
  634.     store value cNew into cOld
  635.   endif
  636.   return(cc)
  637.  
  638.  
  639. //*****************************************************************************
  640. function SetDialog(lNew)
  641.   static lShowDOut:=true
  642.   return lShowDOut update with lNew
  643.  
  644.  
  645. //#############################################################################
  646. // LOW LEVEL INTERFACE
  647. //#############################################################################
  648. //
  649. function SkipDeleted()
  650.   local Rn:=RecNo()
  651.   while !Eof() and Deleted(); skip; endwhile
  652.   if Eof()
  653.     go top
  654.     while Deleted() and RecNo()<Rn; skip; endwhile
  655.     if RecNo()>=Rn
  656.       go bottom
  657.       skip
  658.       return(false)
  659.     endif
  660.   endif
  661.   return(true)
  662.  
  663.  
  664. //*****************************************************************************
  665. function MidStr(S,l,r)
  666.   default l to 1, r to 1
  667.   return(SubStr(S,l,Len(S)+2-l-r))
  668.  
  669.  
  670. //*****************************************************************************
  671. function AWidth(aArray,bWidth)          //author Mike Schinkel (Nantucket news vol.4, No.4, 1991), modified by JHK.
  672.   local nWidth:=0
  673.   default bWidth to {|e| Len(e)}
  674.   AEval(aArray,{|e|nWidth:=Max(nWidth,Eval(bWidth,e))})
  675.   return(nWidth)
  676.  
  677.  
  678. //*****************************************************************************
  679. function ListAsArray(cList,cDelimiter)  //copyright Nantucket Corporation, 1990, modified by JHK.
  680.   local i,aList:={}
  681.   if Empty(cList); return(aList); endif
  682.   default cDelimiter to ","
  683.   while (i:=At(cDelimiter,cList))<>0
  684.     AAdd(aList,SubStr(cList,1,i-1))
  685.     cList:=SubStr(cList,i+1)
  686.   endwhile
  687.   AAdd(aList,cList)
  688.   return(aList)
  689.  
  690.  
  691. //*****************************************************************************
  692. function SwapColor(Clr)
  693.   return(SubStr(Clr,1+At("/",Clr))+"/"+Left(Clr,At("/",Clr)-1))
  694.  
  695.  
  696. //*****************************************************************************
  697. function GetFore(Clr)                    //color
  698.   return(Left(Clr,At("/",Clr)-1))
  699.  
  700.  
  701. //*****************************************************************************
  702. function GetBack(Clr)                    //color
  703.   return(SubStr(Clr,At("/",Clr)+1))
  704.  
  705.  
  706. //*****************************************************************************
  707. function GetField(c)                          //select->FIELD
  708.   return(AllTrim(SubStr(c,At(">",c)+1)))
  709.  
  710.  
  711. //*****************************************************************************
  712. function GetSelect(c)                         //SELECT->field
  713.   local i
  714.   if (i:=At("->",c))>0; c:=AllTrim(SubStr(c,1,i-1)); endif
  715.   return(c)
  716.  
  717.  
  718. //*****************************************************************************
  719. function GetAlias(c)                          //a:\dir1\dirn\ALIAS.dbf
  720.   local i
  721.   c:=SubStr(c,RAt("\",c)+1)
  722.   c:=SubStr(c,RAt(":",c)+1)
  723.   if (i:=At(".",c))>0; c:=SubStr(c,1,i-1); endif
  724.   return(c)
  725.  
  726.  
  727. //*****************************************************************************
  728. function IEval(nCount,bBlock)        //copyright Nantucket Corporation, 1990
  729.   local ValResult,i
  730.   for i:=1 to nCount; ValResult:=Eval(bBlock,i); endfor
  731.   return(ValResult)
  732.  
  733.  
  734. //*****************************************************************************
  735. function WEval(bExpression,bBlock)
  736.   while Eval(bExpression)
  737.     returnif !Eval(bBlock) with false
  738.   endwhile
  739.   return true
  740.  
  741.  
  742. //*****************************************************************************
  743. function ATrueDel(aArray,nPosition)   //copyright Nantucket Corporation, 1990
  744.   local x:=aArray[nPosition]          //modified by JHK, JHK-Software
  745.   ADel(aArray,nPosition)
  746.   ASize(aArray,Len(aArray)-1)
  747.   return(x)
  748.  
  749.  
  750. //*****************************************************************************
  751. function ATrueIns(aArray,nPosition,xValue)
  752.   AAdd(aArray,nil)
  753.   fill empty nPosition with Len(aArray)
  754.   AIns(aArray,nPosition)
  755.   store value xValue into aArray[nPosition]
  756.   return(aArray)
  757.  
  758.  
  759. //*****************************************************************************
  760. function ATailDel(aArray)
  761.   local x:=ATail(aArray)
  762.   ASize(aArray,Len(aArray)-1)
  763.   return(x)
  764.  
  765.  
  766. //*****************************************************************************
  767. function PrintCodes(cCtrlCode)     //copyright Nantucket Corporation, 1990
  768.   local nRow := PRow()
  769.   local nCol := PCol()
  770.   local lPrinter := Set(_SET_PRINTER, .T.)     // SET PRINTER ON
  771.   local lConsole := Set(_SET_CONSOLE, .F.)     // SET CONSOLE OFF
  772.   ?? cCtrlCode
  773.   SetPrc(nRow, nCol)
  774.   Set(_SET_PRINTER, lPrinter)                  // Restore printer setting
  775.   Set(_SET_CONSOLE, lConsole)                  // Restore console setting
  776.   return(true)
  777.  
  778.  
  779. //*****************************************************************************
  780. function SetShowTime(new)
  781.   static old:=true
  782.   return old update with new
  783.  
  784.  
  785. //*****************************************************************************
  786. function SetShowText(new)
  787.   static old:=true
  788.   return old update with new
  789.  
  790.  
  791. //*****************************************************************************
  792. function ShowText(Txt)
  793.   static old:=""
  794.   local CurSize,S,R,C
  795.   if !Empty(Txt)
  796.     S:=if(Len(Txt)<Len(old),Space(Len(old)-Len(txt)),"")+;
  797.        if(Empty(AllTrim(Txt)),"  ","≥ ")+Txt+" "
  798.     old:=if(Empty(AllTrim(Txt)),"",Txt)
  799.   else
  800.     S:=if(Empty(old),"","≥ "+old+" ")
  801.   endif
  802.   if !Empty(S) and SetShowText()
  803.     R:=Row()
  804.     C:=Col()
  805.     DispBegin()
  806.     CurSize:=SetCursor(SC_NONE)
  807.     @ 0,MaxCol()-Len(S)+1 say S color m->Color:Menu
  808.     SetPos(R,C)
  809.     SetCursor(CurSize)
  810.     DispEnd()
  811.   endif
  812.   return(old)
  813.  
  814.  
  815. //*****************************************************************************
  816. function ShowTime(Tm)
  817.   static oTm:="00:00:00"
  818.   returnif !SetShowTime() with ShowText()
  819.   default Tm:=Time()
  820.   if !(oTm==Tm)
  821.     oTm:=Tm
  822.     ShowText(Tm)
  823.   endif
  824.   return(Tm)
  825.  
  826.  
  827. //*****************************************************************************
  828. function GetKey(nSecs)
  829.   local n, nKey
  830.   default nSecs:=0.001
  831.   if( nSecs==0, nSecs:=9999999, )
  832.   n:=Seconds()
  833.   repeat
  834.     ShowTime()
  835.     nKey:=Inkey()
  836.   until nKey<>0 or (Seconds()-n)>=nSecs
  837.   return(nKey)
  838.  
  839.  
  840. //*****************************************************************************
  841. function InKeyWait( nSecs )          //copyright Nantucket Corporation, 1990
  842.   local nKey, bKeyBlock              //modified by JHK, JHK-Software, Piestany
  843.   nKey:=GetKey(nSecs)
  844.   if (bKeyBlock:=SetKey(nKey)) != nil
  845.     Eval(bKeyBlock, ProcName(2), ProcLine(2))
  846.   endif
  847.   return(nKey)
  848.  
  849.  
  850. //*****************************************************************************
  851. function PauseKey( nSecs )           //idea from Nantucket Corporation, 1990
  852.   local nKey                         //written by JHK, JHK-Software, Piestany.
  853.   repeat
  854.     nKey:=InKeyWait(nSecs)
  855.   until SetKey(nKey)==nil
  856.   return(nKey)
  857.  
  858.  
  859. //*****************************************************************************
  860. function StuffKey( nKey )
  861.   local c:=Chr(nKey)
  862.   while NextKey()<>0; c+=Chr(InKey()); endwhile
  863.   __Keyboard(c)
  864.   return(true)
  865.  
  866.  
  867. //*****************************************************************************
  868. function StuffKeys( cKeys )
  869.   while NextKey()<>0; cKeys+=Chr(InKey()); endwhile
  870.   __Keyboard(cKeys)
  871.   return(true)
  872.  
  873.  
  874. //*****************************************************************************
  875. function SetLastKey( nKey )
  876.   StuffKey(nKey)
  877.   return(InKey())
  878.  
  879.  
  880. //*****************************************************************************
  881. function SetQuickEsc( lNew )
  882.   static lQuickEsc:=true
  883.   return lQuickEsc update with lNew
  884.  
  885.  
  886. //*****************************************************************************
  887. function SetDateTime( lNew )
  888.   static lDateTime:=false
  889.   return lDateTime update with lNew
  890.  
  891.  
  892. //*****************************************************************************
  893. procedure RefreshRow()
  894.   local vue,tb
  895.   vue:=ATail(GetWList())
  896.   if !vue:FormActive
  897.     tb:=vue:Tb
  898.     tb:RefreshCurrent()
  899.     while !tb:Stabilize(); endwhile
  900.   endif
  901.   return
  902.  
  903.  
  904. //*****************************************************************************
  905. procedure RefreshTable()
  906.   local vue,tb
  907.   vue:=ATail(GetWList())
  908.   if !vue:FormActive
  909.     SaveDOut("Prekreslujem okno...")
  910.     DispBegin()
  911.       tb:=vue:Tb
  912.       tb:RefreshAll()
  913.       while !tb:Stabilize(); endwhile
  914.     DispEnd()
  915.     RestDOut()
  916.   endif
  917.   return
  918.  
  919.  
  920. //*****************************************************************************
  921. // Vypocita pocet dni v danom mesiaci
  922. //
  923. function DaysInMonth(Month,Year)
  924.   local r4,Days
  925.   default Year:=Year(Date())
  926.   r4:=Year/4
  927.   do case
  928.     case Month==1;  Days:=31
  929.     case Month==2;  Days:=if(Int(r4)==r4,29,28)
  930.     case Month==3;  Days:=31
  931.     case Month==4;  Days:=30
  932.     case Month==5;  Days:=31
  933.     case Month==6;  Days:=30
  934.     case Month==7;  Days:=31
  935.     case Month==8;  Days:=31
  936.     case Month==9;  Days:=30
  937.     case Month==10; Days:=31
  938.     case Month==11; Days:=30
  939.     case Month==12; Days:=31
  940.   endcase
  941.   return(Days)
  942.  
  943.  
  944. //*****************************************************************************
  945. // GoodBye() --> true
  946. // write text and play the song
  947. //
  948. function GoodBye()
  949.   SetCursor(SC_NORMAL)
  950.   SetColor(m->Color:Black)
  951.   clear screen
  952.   replicate(chr(13)+chr(10),5)
  953.   ? "                                                                            "
  954.   ? "                                                                "
  955.   ? "                                                                       "
  956.   ? "                                                                        "
  957.   ? "                                                                        "
  958.   ? "                                                      "
  959.   ? "                                                          "
  960.   ? "                                                          "
  961.   ? "                                                              "
  962.   ? "                                                  "
  963.   ? "                                                                           "
  964.   ? "                                                                    (c)JHK "
  965.   ?
  966.   ?
  967.   BlueDanu()
  968.   return(true)
  969.  
  970.  
  971. //-----------------------------------------------------------------------------
  972. //                            Author: Greg Lief
  973. //                         Copyright (c) 1989, Greg Lief
  974. //                         Plays the Blue Danube Waltz
  975. procedure BlueDanu()
  976.   local tonestr, durstr, xx
  977.   tonestr = ' 293 293 370 440 440 015 880 880 015 740 740 015 293 293 370'
  978.   tonestr = tonestr + ' 440 440 015 880 880 015 784 784 015 277 277 329 493'
  979.   tonestr = tonestr + ' 493 015 986 986 015 784 784 015 277 277 329 493 493'
  980.   tonestr = tonestr + ' 015 986 986 015 740 740 015 293 293 370 440 587 015'
  981.   tonestr = tonestr + '11741174 015 880 880 015 293 293 370 440 587 015'
  982.   tonestr = tonestr + '11741174 015 987 987 015 329 329 392 493'
  983.   tonestr = tonestr + ' 493 415 440 740 587 370 370 329 493 440 293 370 440 587'
  984.   durstr = Replicate('04', 76) + '1604041604040804080404040404'
  985.   for xx:=1 to 6
  986.     Tone(Val(SubStr(tonestr,(xx-1)*4+1,4)),Val(SubStr(durstr,(xx-1)*2+1,2)))
  987.   endfor
  988.   do while NextKey()==0
  989.      Tone(Val(SubStr(tonestr,(xx-1)*4+1,4)),Val(SubStr(durstr,(xx-1)*2+1,2)))
  990.      xx:=if(xx>90, 1, xx+1)
  991.   enddo
  992.   if NextKey()<>0;  InKeyWait(0);  endif
  993.   return
  994.  
  995.  
  996. //*****************************************************************************
  997. // Turn clipper output device to screen, printer or file.
  998. //
  999. procedure OutputDevice(What,lAdditive)
  1000.   default lAdditive to false
  1001.   do case
  1002.     case What==OD_SCREEN
  1003.       set printer to
  1004.       set printer off
  1005.       set device to screen
  1006.       set console on
  1007.     case What==OD_PRINTER
  1008.       set device to printer
  1009.       set printer on
  1010.       set printer to
  1011.       set console off
  1012.     otherwise //file
  1013.       set device to printer
  1014.       set printer on
  1015.       set console off
  1016.       if lAdditive
  1017.         set printer to (What) Additive
  1018.       else
  1019.         set printer to (What)
  1020.       endif
  1021.   endcase
  1022.   return
  1023.  
  1024.  
  1025. //*****************************************************************************
  1026. // PrintFunctions...
  1027. //
  1028. procedure PrintOn()
  1029.   OutputDevice(OD_PRINTER)
  1030.   return
  1031.  
  1032. procedure PrintOff()
  1033.   OutputDevice(OD_SCREEN)
  1034.   return
  1035.  
  1036. function PageLength(new)  
  1037.   static old:=65
  1038.   return old update with new
  1039.  
  1040. #define READ_EOF   -1
  1041. #define READ_OK     0
  1042. #define READ_ERROR +1
  1043. #define READ_ABORT +2
  1044.  
  1045. function PrintFile(FName)
  1046.   local fd,i,j,k
  1047.   local OfsPage,Oe
  1048.   local PageNo:=EditIt(1,ResTxt(195),"999",,,,"SYS:->PAGE_NO")
  1049.   returnif LastKey()==K_ESC with false
  1050.   SaveDOut(ResTxt(197))  //please wait, printing...
  1051.   fd:=FOpen(FName)
  1052.   returnif FError()<>0 with Alert(ResTxt(198)+NTrim(FError())),RestDOut(),false
  1053.   SetLastKey(0)
  1054.   PrintOn()
  1055.     //skip requested pages
  1056.     for i:=2 to PageNo
  1057.       for j:=1 to PageLength()
  1058.         k:=ReadLine(fd)
  1059.         returnif k==READ_EOF   with DonePrint(),Alert(ResTxt(199)+NTrim(PageNo)+ResTxt(200)),false
  1060.         returnif k==READ_ERROR with DonePrint(),Alert(ResTxt(201)+NTrim(FError())),false
  1061.         returnif k==READ_ABORT with DonePrint(),false
  1062.       endfor
  1063.     endfor
  1064.     //out of next pages
  1065.     k:=READ_OK //assume
  1066.     repeat
  1067.     begin break
  1068.       OfsPage:=FSeek(fd,0,FS_RELATIVE)
  1069.       ?? ResTxt(203)+NTrim(PageNo)+cr_lf  //PageNo=
  1070.       i:=2                                //current line
  1071.       repeat
  1072.         k:=ReadLine(fd,@j)
  1073.         if( k==READ_OK, QQOut(j), )
  1074.         i++
  1075.       until k<>READ_OK or i>PageLength()
  1076.       eject
  1077.       PageNo++
  1078.     recover break using Oe
  1079.       PrintOff()
  1080.       if(Oe:genCode<>EG_PRINT, Eval(ErrorBlock(),Oe), )
  1081.       if(Alert(ResTxt(204),ResTxt(205))==2, k:=READ_ABORT, )
  1082.       FSeek(fd,OfsPage,FS_SET)
  1083.       PrintOn()
  1084.     end break
  1085.     until k<>READ_OK
  1086.   DonePrint()
  1087.   return true
  1088.  
  1089. static procedure DonePrint(fd)
  1090.   PrintOff()
  1091.   FClose(fd)
  1092.   RestDOut()
  1093.   return
  1094.   
  1095. static function ReadLine(fd,line)  //return: READ_OK | READ_EOF | READ_ERROR | READ_ABORT
  1096.   local buffer,i
  1097.   local origin:=FSeek(fd,0,FS_RELATIVE)
  1098.   local bottom:=FSeek(fd,0,FS_END)
  1099.   returnif origin==bottom with READ_EOF
  1100.   buffer:=Space(nMaxPrintCols)
  1101.   FSeek(fd,origin,FS_SET)
  1102.   FRead(fd,@buffer,nMaxPrintCols)
  1103.   i:=At(cr_lf,buffer)
  1104.   line:=if(i==0,buffer,Left(buffer,i+1))
  1105.   FSeek(fd,origin+Len(line),FS_SET)
  1106.   returnif FError()>0 with READ_ERROR
  1107.   if NextKey()==K_ESC
  1108.     Inkey(0)
  1109.     PrintOff()
  1110.     returnif Alert(ResTxt(202),ResTxt(123))==1 with READ_ABORT
  1111.     PrintOn()
  1112.   endif
  1113.   return READ_OK
  1114.  
  1115.  
  1116.  
  1117. //*****************************************************************************
  1118. // Don't allow to running program after the date...
  1119. //
  1120. function DateLimit(new)
  1121.   static  old:=nil
  1122.   return old update with new
  1123.  
  1124.  
  1125. //*****************************************************************************
  1126. // Save the database state, no all values, only minimum for select and seek.
  1127. //
  1128. procedure SwapDatabase(cAlias,nOrder)
  1129.   local s:=Select()
  1130.   local r:=RecNo()
  1131.   select (cAlias)
  1132.   AAdd(DatabInfo,{s,r,RecNo(),IndexOrd()}) //origin_Select, origin_RecNo, new_RecNo, new_Order
  1133.   if nil<>nOrder; set order to nOrder; endif
  1134.   return
  1135.  
  1136.  
  1137. //-----------------------------------------------------------------------------
  1138. // Restore (previous saved) database state
  1139. //
  1140. procedure RestDatabase()
  1141.   local x:=ATailDel(DatabInfo)
  1142.   set order to (x[4])
  1143.   go (x[3])
  1144.   select (x[1])
  1145.   go (x[2])
  1146.   return
  1147.  
  1148.  
  1149. //*****************************************************************************
  1150. // Swap display modes.
  1151. //
  1152. procedure SwapVGALine()
  1153.   SetMode( if(MaxRow()>25,25,50), 80 )
  1154.   RePaintDesktop()
  1155.   return
  1156.  
  1157. procedure SwapEGALine()
  1158.   SetMode( if(MaxRow()>25,25,43), 80 )
  1159.   RePaintDesktop()
  1160.   return
  1161.  
  1162.  
  1163.  
  1164. //#############################################################################
  1165. // NET SUPPORT:
  1166. // all functions vill be return !NETERR() and keep correct NETERR()
  1167. //
  1168. //-----------------------------------------------------------------------------
  1169. function NetDbCreate(cFile,aStructure,lContinue)
  1170.   if Right(AllTrim(Upper(cFile)),4)==".DBF"
  1171.     cFile:=MidStr(cFile,,5)  //forget extension
  1172.   endif
  1173.   if !NetFErase(cFile+".DBF",lContinue); return(false); endif
  1174.   if !NetFErase(cFile+".DBT",lContinue); return(false); endif
  1175.   retur( NetProcedure( {||DbCreate(cFile,aStructure),!NetErr()}, ResTxt(112)+" "+cFile, lContinue ))
  1176.  
  1177.  
  1178. //-----------------------------------------------------------------------------
  1179. function NetCreateFrom(cFile1,cFile2,lContinue)
  1180.   if Right(AllTrim(Upper(cFile1)),4)==".DBF"
  1181.     cFile1:=MidStr(cFile1,,5)  //forget extension
  1182.   endif
  1183.   if !NetFErase(cFile1+".DBF",lContinue); return(false); endif
  1184.   if !NetFErase(cFile1+".DBT",lContinue); return(false); endif
  1185.   return(NetProcedure( {||__DbCreate(cFile1,cFile2),!NetErr()}, ResTxt(112)+" "+cFile1, lContinue ))
  1186.  
  1187.  
  1188. //-----------------------------------------------------------------------------
  1189. function NetDbUseArea(new,rdd,db,a,shex,ro,lContinue)
  1190.   return(NetProcedure( {||DbUseArea(new,rdd,db,a,shex,ro),!NetErr()}, ResTxt(113)+" "+db, lContinue ))
  1191.  
  1192.  
  1193. //-----------------------------------------------------------------------------
  1194. function NetIndexOn(cFile,cKey,bKey,lUnique,lContinue)
  1195.   if !NetFErase(GetAlias(cFile)+".ntx",lContinue); return(false); endif
  1196.   return(NetProcedure( {||DbCreateIndex(cFile,cKey,bKey,lUnique),!NetErr()}, ResTxt(108)+" "+cFile+".ntx", lContinue ))
  1197.  
  1198.  
  1199. //----------------------------------------------------------------------------
  1200. function NetSetIndex(cListFiles,lContinue)
  1201.   if Left(cListFiles,1)=='"'; cListFiles:=MidStr(cListFiles,2,2); endif
  1202.   return(NetProcedure( {||SetIndexBlock(cListFiles)}, ResTxt(109)+" "+cListFiles, lContinue ))
  1203.  
  1204. static function SetIndexBlock(cListFiles)
  1205.   DbClearIndex()
  1206.   AEval(ListAsArray(cListFiles),{|e|DbSetIndex(if(Left(e,1)=='"',MidStr(e,2,2),e))})
  1207.   return(!NetErr())
  1208.  
  1209.  
  1210. //-----------------------------------------------------------------------------
  1211. function NetDbAppend(lContinue)
  1212.   return(NetProcedure( {||DbAppend(),DbCommit(),!NetErr()}, ResTxt(114), lContinue ))
  1213.  
  1214.  
  1215. //-----------------------------------------------------------------------------
  1216. function NetDbDelete(lContinue)
  1217.   return(NetProcedure( {||if(RLock(),(DbDelete(),DbCommit(),DbUnLock(),true),false)}, ResTxt(116), lContinue ))
  1218.  
  1219.  
  1220. //-----------------------------------------------------------------------------
  1221. function NetDbRecall(lContinue)
  1222.   return(NetProcedure( {||if(RLock(),(DbRecall(),DbCommit(),DbUnLock(),true),false)}, ResTxt(115), lContinue ))
  1223.  
  1224.  
  1225. //-----------------------------------------------------------------------------
  1226. function NetReplace(bRepl,lContinue)
  1227.   return(NetProcedure( {||if(RLock(),(Eval(bRepl),DbCommit(),DbUnLock(),true),false)}, ResTxt(111), lContinue ))
  1228.  
  1229.  
  1230. //-----------------------------------------------------------------------------
  1231. function NetReplSeek(bRepl,xExpr,lContinue)
  1232.   seek xExpr
  1233.   while Found()
  1234.     returnif !NetProcedure( {||if(RLock(),(Eval(bRepl),DbCommit(),DbUnLock(),true),false)}, ResTxt(111), lContinue ) with false
  1235.     seek xExpr
  1236.   endwhile
  1237.   return true
  1238.  
  1239.  
  1240. //-----------------------------------------------------------------------------
  1241. function NetRLock(lContinue)
  1242.   return(NetProcedure( {||RLock()}, ResTxt(111), lContinue ))
  1243.  
  1244.  
  1245. //-----------------------------------------------------------------------------
  1246. function NetFLock(lContinue)
  1247.   return(NetProcedure( {||FLock()}, ResTxt(110), lContinue ))
  1248.  
  1249.  
  1250. //-----------------------------------------------------------------------------
  1251. function NetFErase(cFile,lContinue)
  1252.   if !File(cFile); NetErr(false); return(true); endif
  1253.   return(NetProcedure( {||FErase(cFile)==0}, ResTxt(107)+" "+cFile, lContinue ))
  1254.  
  1255.  
  1256. //-----------------------------------------------------------------------------
  1257. function NetReIndex(lContinue)
  1258.   local l:=true
  1259.   begin break
  1260.     reindex
  1261.   recover break
  1262.     l:=GetOneDbf(Alias()):ReIndex(lContinue)
  1263.   end break
  1264.   return(l)
  1265.  
  1266.  
  1267. //-----------------------------------------------------------------------------
  1268. function NetPack(lContinue)
  1269.   local l:=true
  1270.   begin break
  1271.     pack
  1272.   recover break
  1273.     l:=GetOneDbf(Alias()):Pack(lContinue)
  1274.   end break
  1275.   return(l)
  1276.  
  1277.  
  1278. //-----------------------------------------------------------------------------
  1279. function NetZap(lContinue)
  1280.   local l:=true
  1281.   begin break
  1282.     zap
  1283.   recover break
  1284.     l:=GetOneDbf(Alias()):Zap(lContinue)
  1285.   end break
  1286.   return(l)
  1287.  
  1288.  
  1289. //-----------------------------------------------------------------------------
  1290. static function NetProcedure(bProc,cAlertText,lContinue)
  1291.   local cChoice,nChoice,nWaitSec,x
  1292.   default lContinue to true
  1293.   cChoice:=if(lContinue,ResTxt(127),ResTxt(126))
  1294.   repeat
  1295.     nWaitSec:=nNetWaitSec
  1296.     while nWaitSec>0
  1297.       begin break
  1298.         x:=false
  1299.         x:=Eval(bProc)
  1300.       end break
  1301.       if x; NetErr(false); return(true); endif
  1302.       InKeyWait(.1)
  1303.       nWaitSec-=.2
  1304.     endwhile
  1305.     nChoice:=Alert(cAlertText,cChoice)
  1306.     if nChoice==2 and !lContinue; nChoice++; endif
  1307.     if nChoice==3
  1308.       if Alert(ResTxt(106),ResTxt(123))<>1; nChoice:=1; endif
  1309.     endif
  1310.   until nChoice<>1
  1311.   if nChoice==3; ObjectDone(); quit; endif
  1312.   NetErr(true)
  1313.   return(false)
  1314.  
  1315.  
  1316. //*****************************************************************************
  1317. // LogOn()
  1318. // increment users counter for tracking index files integrity. (see Dbf:Open())
  1319. //
  1320. function LogOn()
  1321.   return(LogActivity({||field->ViewID++}))
  1322.  
  1323.  
  1324. //*****************************************************************************
  1325. // LogOff()
  1326. // decrement users counter for tracking index files integrity. (see Dbf:Done())
  1327. //
  1328. function LogOff()
  1329.   return(LogActivity({||field->ViewID--}))
  1330.  
  1331.  
  1332. //*****************************************************************************
  1333. // LogClear()
  1334. // zeroes users counter for tracking index files integrity. (see Dbf:Load())
  1335. //
  1336. function LogClear()
  1337.   return(LogActivity({||field->ViewID:=0}))
  1338.  
  1339.  
  1340. //*****************************************************************************
  1341. // LogSet([nUsers])
  1342. // set users counter.
  1343. //
  1344. function LogSet(nUsers)
  1345.   local tmp:=LogActivity({||field->ViewID},true)
  1346.   if( !Empty(nUsers), LogActivity( {||field->ViewID:=nUsers} ), )
  1347.   return(tmp)
  1348.  
  1349.  
  1350. //*****************************************************************************
  1351. // NetLimit([new_limit])
  1352. // maximum users currently working  with the program.
  1353. //
  1354. function NetLimit(new)
  1355.   static old:=990      //999 is RESERVED AS LOADING MARK !!!
  1356.   return old update with new
  1357.  
  1358.  
  1359. //*****************************************************************************
  1360. // LogActivity(Block,Return_request)
  1361. // work around tracking index files integrity
  1362. // I wish to thank mr. Saferna (OKD Ostrava) for good idea
  1363. // about 'multiuser crash test' implemented into this object.lib
  1364. //
  1365. static function LogActivity(Block,ret_req)
  1366.   local r,s:=Select()
  1367.   default ret_req:=false
  1368.   begin break
  1369.     select (cIFR)
  1370.     go 1
  1371.     net rlock
  1372.     r:=Eval(Block)
  1373.     net unlock
  1374.   recover break
  1375.     begin break
  1376.       use (cIFR) exclusive new
  1377.       go 1
  1378.       r:=Eval(Block)
  1379.       close
  1380.     recover break
  1381.       select (s)
  1382.       return(if(ret_req,r,false))
  1383.     end break
  1384.   end break
  1385.   select (s)
  1386.   return(if(ret_req,r,true))
  1387.  
  1388.  
  1389. //-------------------------------------------------- eof (c)JHK ---------------
  1390.  
  1391.